perm filename TR3.F4[STR,LCS] blob sn#339452 filedate 1978-03-09 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C00015 ENDMK
CāŠ—;
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY.  IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
        SUBROUTINE MPACK(KCNT, I,IX,IPTR)
	COMMON/IGEN/IGEN
	COMMON /TR/Q(80),QX(100),NN(2),LX(12),INST(27,5),MX5(40)
	DIMENSION I(1)
	IX=I(1)
	DO 100 K=1,12
	IF(IX.NE.LX(K))GO TO 100
C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
	RETURN
100	CONTINUE
101	N=I(2)
	L=I(3)
	IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
	IF(IX.EQ.'P')GO TO 14
	IF(IX.EQ.'F')GO TO 15
	IF(IX.EQ.'B')GO TO 16
	IF(IX.EQ.'A')GO TO 1
	IF(IX.EQ.'O')GO TO 2
	IF(IX.EQ.'R')GO TO 3
	IF(IX.EQ.'E')GO TO 4
	IF(IX.EQ.'S')GO TO 5
	IF(IX.EQ.'M')GO TO 17   
	IF(IX.EQ.'I')GO TO 33
C IF NOT A KNOWN WORD THEN ERROR
999	CALL ERR(5)
C NEXT FOR 'MLT'
17	IF(N.NE.'L')GO TO 999
	IF(L.NE.'T')GO TO 999
	IX=9
	RETURN
1	IF(N.NE.'D')GO TO 999
	IF(L.EQ.'2')GO TO 6
C 'AD2, AD3, AD4'
	IF(L.EQ.'3')GO TO 7
	IF(L.NE.'4')GO TO 999
	IX=8
	RETURN
6	IX=3
	RETURN
7	IX=7
	RETURN
2	IF(N.EQ.'S')GO TO 10
	IF(N.NE.'U')GO TO 999
	IF(L.NE.'T')GO TO 999
C 'OUT'
	IX=1
	RETURN
10	IF(L.NE.'C')GO TO 999
C 'OSC'
	IX=2
	RETURN
3	IF(N.NE.'A')GO TO 999
	IF(L.EQ.'N')GO TO 11
	IF(L.NE.'H')GO TO 999
C 'RAN', 'RAH'
	IX=11
	RETURN
11	IX=4
	RETURN
4	IF(N.NE.'N')GO TO 999
	IF(L.EQ.'V')GO TO 12
C ENV, END
	IF(L.NE.'D')GO TO 999
	IX=12
	RETURN
12	IX=5
	RETURN
5	IF(N.EQ.'T')GO TO 13
	IF(N.NE.'E')GO TO 999
C SET, STR
	IF(L.NE.'T')GO TO 999
	IX=10
	RETURN
13	IF(L.NE.'R')GO TO 999
	IX=6
	RETURN
14	J=200
C PN
18	IF(N.LT.'0'.OR.N.GT.'9')GO TO 999
	K2=0
	K1=NASCI(N)       
C!**** CHANGE ASCII INTO NUMBER
	IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
	IF(L.LT.'0'.OR.L.GT.'9')GO TO 999
	K1=K1*10
	K2=NASCI(L)               
19	IX=J+K1+K2
	RETURN
15	J=300
C  FN
	GO TO 18
16	J=100
C BN
	GO TO 18

C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000	IF(KCNT.LE.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
	LN=I(4)
	IF(IX.EQ.'P')GO TO 20
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
	IF(IX.EQ.'F')GO TO 21
	IF(IX.EQ.'S')GO TO 22
	IF(IX.EQ.'N')GO TO 23
	IF(IX.EQ.'I')GO TO 27
	IF(IX.NE.'U')GO TO 28
C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
	IF(N.NE.'N')GO TO 28
	IF(L.NE.'I')GO TO 28
	IF(LN.NE.'T')GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
	IX=413
	RETURN
20	IF(N.NE.'L')GO TO 30
	IF(L.NE.'A')GO TO 28
	IF(LN.NE.'Y')GO TO 28
C PLAY
	IX=400
	RETURN
30	IF(N.NE.'R')GO TO 31
	IF(L.NE.'I')GO TO 28
	IF(LN.NE.'N')GO TO 28
C PRINT
	IX=404
	RETURN
31	IF(N.NE.'O')GO TO 28
	IF(L.NE.'W')GO TO 28
	IF(LN.NE.'E')GO TO 28
C POWER(X,Y)
	IX=406
	RETURN
21	IF(N.NE.'I')GO TO 32
	IF(L.NE.'N')GO TO 28
	IF(LN.NE.'I')GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
	IX=401
	RETURN
22	IF(N.NE.'R')GO TO 28
	IF(L.NE.'A')GO TO 29
	IF(LN.NE.'T')GO TO 28
C SRATE, SRT
	IX=402
	RETURN
29	IF(L.NE.'T')GO TO 28
	IX=407
	RETURN
23	IF(N.NE.'C')GO TO 28
	IF(L.NE.'H')GO TO 28
	IF(LN.NE.'N')GO TO 28
C NCHNS
	IX=403
	RETURN
24	IF(N.NE.'H')GO TO 28
	IF(L.NE.'A')GO TO 28
C CHA 
	IX=405
	RETURN
25	IF(N.NE.'E')GO TO 28
	IF(L.NE.'N')GO TO 28
C  GEN 
	IX=409
	RETURN
26	IF(N.NE.'U')GO TO 28
	IF(L.NE.'R')GO TO 28
C DUR
	IX=410
	RETURN
27	IF(N.NE.'N')GO TO 28
	IF(L.NE.'S')GO TO 28
	IF(KCNT.EQ.3)GO TO 33
	IF(LN.NE.'T')GO TO 28
	IF(I(5).NE.'R')GO TO 28
	IF(I(6).NE.'U')GO TO 28
C INSTRUMENT
	IX=412
	RETURN
33	IX=13
C 'INS'
	RETURN
32	IF(N.NE.'R')GO TO 28
	IF(L.NE.'E')GO TO 28
	IF(LN.NE.'Q')GO TO 28
C FREQ
	IX=411
	RETURN
28	IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
	RETURN

2000	IF(IX.EQ.'P')GO TO 14
C FINDS (P1, P21, ETC.)
	IF(IX.NE.'F')GO TO 34
C A FUNC??
	IF(N.GE.'0'.AND.N.LE.'9')GO TO 15
	IF(KCNT.EQ.3)GO TO 28
	IX=510
	GO TO 36
34	IF(IX.NE.'C')GO TO 35
	IF(KCNT.EQ.3)GO TO 34
C JUMP IF NOT A NOTE
	IX=501
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520  (CF TO BS)
	GO TO 36
35	IF(IX.NE.'G')GO TO 38
C NOW A 'GEN' OR A NOTE
	IF(KCNT.EQ.3)GO TO 25
	IX=513
C THE NOTE 'G'
36	IF(KCNT.EQ.1)RETURN
	IF(N.EQ.'F')GO TO 39
	IF(N.NE.'S') GO TO 28
C NOW IT'S NOT A NOTE
40	IX=IX+1
C SHARP
	RETURN
39	IX=IX-1
C FLAT
	RETURN
38	IF(IX.NE.'D')GO TO 41
	IF(KCNT.EQ.3)GO TO 26
C GO LOOK FOR 'DUR'
	IX=504
	GO TO 36
41	IF(IX.EQ.'I')GO TO 27
C CATCHES  'INS'
	IF(IX.NE.'E')GO TO 42
	IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
	IX=507
	GO TO 36
42	IF(KCNT.EQ.3)GO TO 28
	IF(IX.NE.'A')GO TO 43
	IX=516
	GO TO 36
43	IF(IX.NE.'B')GO TO 28
	IX=519
	GO TO 36

	END

CC      SUBROUTINE MPACK(WDCNT, I,NM)
CC    EQUIVALENCE (NMM,NX)
CC    DIMENSION I(1),M(10),NX(2)
CC    DOUBLE PRECISION NM,NMM
CC    INTEGER WDCNT
CC    DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC    DATA MM/"774000000000/

CC    DO 1 K=1,10
CC    M(K)=I(K)
CC1      IF(K.GT.WDCNT)M(K)=' '
CC    JX=0
CC    DO 2 J=1,2
CC    NN=0
CC    DO 10 K=5,1,-1
CC    NN=NN .OR. (M(K+JX) .AND. MM)
CC    IF (K-1) 20,20,17
CC17      IF (NN.GE.0)GO TO 13
CC    NN = (( NN .AND. LL)/KK) .OR. JJ
CC    GO TO 10
CC13      NN = NN / KK
CC10      CONTINUE
CC20      JX=5
CC2       NX(J)=NN
CC    NM=NMM
CC    END
 
      SUBROUTINE ERR(N)
      GO TO (1,2,3,4,5)N
1      TYPE 101
      STOP
101      FORMAT(' MISSING SEMICOLON')
2      TYPE 102
      STOP
102      FORMAT(' MISSING PARENTHESIS')
3      TYPE 103
      STOP
103      FORMAT(' MISSING COMMA')
4      TYPE 104
104      FORMAT(' MISSING PLAY;')
5	TYPE 105
105	FORMAT(' UNKNOWN WORD')
      STOP
      END

      SUBROUTINE ARITH(Y,W,LL)
      DIMENSION W(1)
      COMMON /AR/IOP
47      X=W(LL-1)
      GO TO (41,42,43,44),IOP
41      X=X*Y
      GO TO 45
42      X=X/Y
      GO TO 45
43      X=X-Y
      GO TO 45
44      X=X+Y
45      W(LL-1)=X
      END